home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / cmpnew / cmploc.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  10.0 KB  |  292 lines
  1. ;;; CMPLOC  Set-loc and Wt-loc.
  2. ;;;
  3. ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  4.  
  5. ;; This file is part of GNU Common Lisp, herein referred to as GCL
  6. ;;
  7. ;; GCL is free software; you can redistribute it and/or modify it under
  8. ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  9. ;; the Free Software Foundation; either version 2, or (at your option)
  10. ;; any later version.
  11. ;; 
  12. ;; GCL is distributed in the hope that it will be useful, but WITHOUT
  13. ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14. ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  15. ;; License for more details.
  16. ;; 
  17. ;; You should have received a copy of the GNU Library General Public License 
  18. ;; along with GCL; see the file COPYING.  If not, write to the Free Software
  19. ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.  
  22. (in-package 'compiler)
  23.  
  24. (defvar *value-to-go*)
  25.  
  26. ;;; Valid locations are:
  27. ;;;    NIL
  28. ;;;    T
  29. ;;;    'FUN-VAL'
  30. ;;;    ( 'VS' vs-address )
  31. ;;;    ( 'VS*' vs-address )
  32. ;;;    ( 'CCB-VS' ccb-vs )
  33. ;;;    ( 'VAR' var-object ccb )
  34. ;;;    ( 'VV' vv-index )
  35. ;;;    ( 'CVAR' cvar )
  36. ;;;    ( 'INLINE' side-effect-p fun/string locs )
  37. ;;;    ( 'INLINE-COND' side-effect-p fun/string locs )
  38. ;;;    ( 'INLINE-FIXNUM' side-effect-p fun/string locs )
  39. ;;;    ( 'INLINE-CHARACTER' side-effect-p fun/string locs )
  40. ;;;    ( 'INLINE-LONG-FLOAT' side-effect-p fun/string locs )
  41. ;;;    ( 'INLINE-SHORT-FLOAT' side-effect-p fun/string locs )
  42. ;;;    ( 'SIMPLE-CALL {   SYMLISPCALL-NO-EVENT
  43. ;;;                        | LISPCALL-NO-EVENT
  44. ;;;                        | SYMLISPCALL
  45. ;;;                        | LISPCALL }
  46. ;;;        vs-index number-of-arguments [ vv-index ] )
  47. ;;;    ( 'VS-BASE' offset )
  48. ;;;    ( 'CAR' cvar )
  49. ;;;    ( 'CADR' cvar )
  50. ;;;    ( 'SYMBOL-FUNCTION' vv-index )
  51. ;;;    ( 'MAKE-CCLOSURE' cfun cllink )
  52. ;;;    ( 'FIXNUM-VALUE' vv-index fixnum-value )
  53. ;;;    ( 'FIXNUM-LOC' loc )
  54. ;;;    ( 'CHARACTER-VALUE' vv-index character-code )
  55. ;;;    ( 'CHARACTER-LOC' loc )
  56. ;;;    ( 'LONG-FLOAT-VALUE' vv-index long-float-value )
  57. ;;;    ( 'LONG-FLOAT-LOC' loc )
  58. ;;;    ( 'SHORT-FLOAT-VALUE' vv-index short-float-value )
  59. ;;;    ( 'SHORT-FLOAT-LOC' loc )
  60.  
  61.  
  62. ;;; Valid *value-to-go* locations are:
  63. ;;;
  64. ;;;    'RETURN'    The value is returned from the current function.
  65. ;;;    'RETURN-FIXNUM'
  66. ;;;    'RETURN-CHARACTER'
  67. ;;;    'RETURN-LONG-FLOAT'
  68. ;;;    'RETURN-SHORT-FLOAT'
  69. ;;;    'RETURN-OBJECT
  70. ;;;    'TRASH'        The value may be thrown away.
  71. ;;;    'TOP'        The value should be set at the top of vs as if it were
  72. ;;;            a resulted value of a function call.
  73. ;;;    ( 'VS' vs-address )
  74. ;;;    ( 'VS*' vs-address )
  75. ;;;    ( 'CCB-VS' ccb-vs )
  76. ;;;    ( 'VAR' var-object ccb )
  77. ;;;    ( 'JUMP-TRUE' label )
  78. ;;;    ( 'JUMP-FALSE' label )
  79. ;;;    ( 'BDS-BIND' vv-index )
  80. ;;;    ( 'PUSH-CATCH-FRAME' )
  81. ;;;    ( 'DBIND' symbol-name-vv )
  82.  
  83. (si:putprop 'cvar 'wt-cvar 'wt-loc)
  84. (si:putprop 'vv 'wt-vv 'wt-loc)
  85. (si:putprop 'car 'wt-car 'wt-loc)
  86. (si:putprop 'cdr 'wt-cdr 'wt-loc)
  87. (si:putprop 'cadr 'wt-cadr 'wt-loc)
  88. (si:putprop 'vs-base 'wt-vs-base 'wt-loc)
  89. (si:putprop 'fixnum-value 'wt-fixnum-value 'wt-loc)
  90. (si:putprop 'fixnum-loc 'wt-fixnum-loc 'wt-loc)
  91. (si:putprop 'integer-loc 'wt-integer-loc 'wt-loc)
  92. (si:putprop 'character-value 'wt-character-value 'wt-loc)
  93. (si:putprop 'character-loc 'wt-character-loc 'wt-loc)
  94. (si:putprop 'long-float-value 'wt-long-float-value 'wt-loc)
  95. (si:putprop 'long-float-loc 'wt-long-float-loc 'wt-loc)
  96. (si:putprop 'short-float-value 'wt-short-float-value 'wt-loc)
  97. (si:putprop 'short-float-loc 'wt-short-float-loc 'wt-loc)
  98. (si::putprop 'next-var-arg  'wt-next-var-arg 'wt-loc)
  99.  
  100. (defun wt-next-var-arg ()
  101.   (wt "va_arg(ap,object)"))
  102.  
  103. (defun set-loc (loc &aux fd)
  104.   (cond ((eq *value-to-go* 'return) (set-return loc))
  105.         ((eq *value-to-go* 'trash)
  106.          (cond ((and (consp loc)
  107.                      (member (car loc)
  108.                              '(INLINE INLINE-COND INLINE-FIXNUM inline-integer
  109.                                INLINE-CHARACTER INLINE-LONG-FLOAT
  110.                                INLINE-SHORT-FLOAT))
  111.                      (cadr loc))
  112.                 (wt-nl "(void)(") (wt-inline t (caddr loc) (cadddr loc))
  113.                 (wt ");"))
  114.                ((and (consp loc) (eq (car loc) 'SIMPLE-CALL))
  115.                 (wt-nl "(void)" loc ";"))))
  116.         ((eq *value-to-go* 'top)
  117.          (unless (eq loc 'fun-val) (set-top loc)))
  118.         ((eq *value-to-go* 'return-fixnum) (set-return-fixnum loc))
  119.         ((eq *value-to-go* 'return-character) (set-return-character loc))
  120.         ((eq *value-to-go* 'return-long-float) (set-return-long-float loc))
  121.         ((eq *value-to-go* 'return-short-float) (set-return-short-float loc))
  122.         ((or (not (consp *value-to-go*))
  123.              (not (symbolp (car *value-to-go*))))
  124.          (baboon))
  125.         ((setq fd (get (car *value-to-go*) 'set-loc))
  126.          (apply fd loc (cdr *value-to-go*)))
  127.         ((setq fd (get (car *value-to-go*) 'wt-loc))
  128.          (wt-nl) (apply fd (cdr *value-to-go*)) (wt "= " loc ";"))
  129.         (t (baboon)))
  130.   )
  131.  
  132. (defun wt-loc (loc)
  133.   (cond ((eq loc nil) (wt "Cnil"))
  134.         ((eq loc t) (wt "Ct"))
  135.         ((eq loc 'fun-val) (wt "vs_base[0]"))
  136.         ((or (not (consp loc))
  137.              (not (symbolp (car loc))))
  138.          (baboon))
  139.         (t (let ((fd (get (car loc) 'wt-loc)))
  140.                 (when (null fd) (baboon))
  141.                 (apply fd (cdr loc)))))
  142.   )
  143.  
  144. (defun set-return (loc)
  145.   (cond ((eq loc 'fun-val))
  146.         ((and (consp loc) (eq (car loc) 'vs) (= (caadr loc) *level*))
  147.          (wt-nl "vs_top=(vs_base=base+" (cdadr loc) ")+1;")
  148.          (base-used))
  149.         ((and (consp loc)
  150.               (eq (car loc) 'var)
  151.               (eq (var-kind (cadr loc)) 'LEXICAL)
  152.               (not (var-ref-ccb (cadr loc)))
  153.               (eql (car (var-ref (cadr loc))) *level*))
  154.          (wt-nl "vs_top=(vs_base=base+" (cdr (var-ref (cadr loc))) ")+1;")
  155.          (base-used))
  156.         (t (set-top loc)))
  157.   )
  158.  
  159. (defun set-top (loc)
  160.  (let ((*vs* *vs*))
  161.       (wt-nl) (wt-vs (vs-push)) (wt "= " loc ";")
  162.       (wt-nl "vs_top=(vs_base=base+" (1- *vs*) ")+1;")
  163.       (base-used)))
  164.  
  165. (defun wt-vs-base (offset) (wt "vs_base[" offset "]"))
  166.  
  167. (defun wt-car (cvar) (wt "(V" cvar "->c.c_car)"))
  168.  
  169. (defun wt-cdr (cvar) (wt "(V" cvar "->c.c_cdr)"))
  170.  
  171. (defun wt-cadr (cvar) (wt "(V" cvar "->c.c_cdr->c.c_car)"))
  172.  
  173. (defun wt-cvar (cvar &optional type)
  174.   (if type (wt "/* " (symbol-name type) " */"))
  175.   (wt "V" cvar))
  176.  
  177. (defun wt-vv (vv) (wt "VV[" vv "]"))
  178.  
  179. (defun wt-fixnum-loc (loc)
  180.   (cond ((and (consp loc)
  181.               (eq (car loc) 'var)
  182.               (eq (var-kind (cadr loc)) 'FIXNUM))
  183.          (wt "V" (var-loc (cadr loc))))
  184.         ((and (consp loc) (eq (car loc) 'INLINE-FIXNUM))
  185.          (wt-inline-loc (caddr loc) (cadddr loc)))
  186.         ((and (consp loc) (eq (car loc) 'fixnum-value))
  187.          (wt (caddr loc)))
  188.         ((and (consp loc) (member (car loc) '(INLINE-SHORT-FLOAT
  189.                           INLINE-LONG-FLOAT)))
  190.      (wt "((int)(")
  191.      (wt-inline-loc  (caddr loc) (cadddr loc))
  192.      (wt "))"))
  193.         (t (wt "fix(" loc ")"))))
  194.  
  195. (defun wt-integer-loc (loc &optional type
  196.                &aux (avma t)(first (and (consp loc) (car loc))))
  197.   (case first
  198.     (inline-fixnum
  199.      (wt "stoi(")
  200.      (wt-inline-loc (caddr loc) (cadddr loc))
  201.      (wt ")"))
  202.     (INLINE-INTEGER (setq avma nil)  (wt-inline-loc (caddr loc) (cadddr loc)))
  203.     (fixnum-value       (wt "stoi(" (caddr loc) ")"))
  204.     (var
  205.      (case (var-kind (cadr loc))
  206.        (integer  (setq avma nil)   (wt "V" (var-loc (cadr loc))))
  207.        (fixnum           (wt "stoi(V" (var-loc (cadr loc))")"))
  208.        (otherwise (wt "otoi(" loc ")"))))
  209.     (otherwise (wt "otoi(" loc ")")))
  210.   (and avma (not *restore-avma*)(wfs-error))
  211.   )
  212.      
  213.  
  214. (defun fixnum-loc-p (loc)
  215.   (and (consp loc)
  216.        (or (and (eq (car loc) 'var)
  217.                 (eq (var-kind (cadr loc)) 'FIXNUM))
  218.            (eq (car loc) 'INLINE-FIXNUM)
  219.            (eq (car loc) 'fixnum-value))))
  220.  
  221. (defun wt-fixnum-value (vv fixnum-value)
  222.   (if vv (wt "VV[" vv "]")
  223.     (wt "small_fixnum(" fixnum-value ")")))
  224.         
  225.  
  226. (defun wt-character-loc (loc)
  227.   (cond ((and (consp loc)
  228.               (eq (car loc) 'var)
  229.               (eq (var-kind (cadr loc)) 'CHARACTER))
  230.          (wt "V" (var-loc (cadr loc))))
  231.         ((and (consp loc) (eq (car loc) 'INLINE-CHARACTER))
  232.          (wt-inline-loc (caddr loc) (cadddr loc)))
  233.         ((and (consp loc) (eq (car loc) 'CHARACTER-VALUE))
  234.          (wt (caddr loc)))
  235.         (t (wt "char_code(" loc ")"))))
  236.  
  237. (defun character-loc-p (loc)
  238.   (and (consp loc)
  239.        (or (and (eq (car loc) 'var)
  240.                 (eq (var-kind (cadr loc)) 'CHARACTER))
  241.            (eq (car loc) 'INLINE-CHARACTER)
  242.            (eq (car loc) 'character-value))))
  243.  
  244. (defun wt-character-value (vv character-code)
  245.        (declare (ignore character-code))
  246.        (wt "VV[" vv "]"))
  247.  
  248. (defun wt-long-float-loc (loc)
  249.   (cond ((and (consp loc)
  250.               (eq (car loc) 'var)
  251.               (eq (var-kind (cadr loc)) 'LONG-FLOAT))
  252.          (wt "V" (var-loc (cadr loc))))
  253.         ((and (consp loc) (eq (car loc) 'INLINE-LONG-FLOAT))
  254.          (wt-inline-loc (caddr loc) (cadddr loc)))
  255.         ((and (consp loc) (eq (car loc) 'long-float-value))
  256.          (wt (caddr loc)))
  257.         (t (wt "lf(" loc ")"))))
  258.  
  259. (defun long-float-loc-p (loc)
  260.   (and (consp loc)
  261.        (or (and (eq (car loc) 'var)
  262.                 (eq (var-kind (cadr loc)) 'LONG-FLOAT))
  263.            (eq (car loc) 'INLINE-LONG-FLOAT)
  264.            (eq (car loc) 'long-float-value))))
  265.  
  266. (defun wt-long-float-value (vv long-float-value)
  267.        (declare (ignore long-float-value))
  268.        (wt "VV[" vv "]"))
  269.  
  270. (defun wt-short-float-loc (loc)
  271.   (cond ((and (consp loc)
  272.               (eq (car loc) 'var)
  273.               (eq (var-kind (cadr loc)) 'SHORT-FLOAT))
  274.          (wt "V" (var-loc (cadr loc))))
  275.         ((and (consp loc) (eq (car loc) 'INLINE-SHORT-FLOAT))
  276.          (wt-inline-loc (caddr loc) (cadddr loc)))
  277.         ((and (consp loc) (eq (car loc) 'short-float-value))
  278.          (wt (caddr loc)))
  279.         (t (wt "sf(" loc ")"))))
  280.  
  281. (defun short-float-loc-p (loc)
  282.   (and (consp loc)
  283.        (or (and (eq (car loc) 'var)
  284.                 (eq (var-kind (cadr loc)) 'SHORT-FLOAT))
  285.            (eq (car loc) 'INLINE-SHORT-FLOAT)
  286.            (eq (car loc) 'short-float-value))))
  287.  
  288. (defun wt-short-float-value (vv short-float-value)
  289.        (declare (ignore short-float-value))
  290.        (wt "VV[" vv "]"))
  291.  
  292.